home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / w3 / url-file.el.z / url-file.el
Encoding:
Text File  |  1998-05-21  |  8.5 KB  |  266 lines
  1. ;;; url-file.el --- File retrieval code
  2. ;; Author: wmperry
  3. ;; Created: 1997/12/24 23:06:53
  4. ;; Version: 1.26
  5. ;; Keywords: comm, data, processes
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;; Copyright (c) 1993-1996 by William M. Perry <wmperry@cs.indiana.edu>
  9. ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
  10. ;;;
  11. ;;; This file is not part of GNU Emacs, but the same permissions apply.
  12. ;;;
  13. ;;; GNU Emacs is free software; you can redistribute it and/or modify
  14. ;;; it under the terms of the GNU General Public License as published by
  15. ;;; the Free Software Foundation; either version 2, or (at your option)
  16. ;;; any later version.
  17. ;;;
  18. ;;; GNU Emacs is distributed in the hope that it will be useful,
  19. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ;;; GNU General Public License for more details.
  22. ;;;
  23. ;;; You should have received a copy of the GNU General Public License
  24. ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25. ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26. ;;; Boston, MA 02111-1307, USA.
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29. (require 'url-vars)
  30. (require 'mule-sysdp)
  31. (require 'url-parse)
  32.  
  33. (defun url-insert-possibly-compressed-file (fname &rest args)
  34.   ;; Insert a file into a buffer, checking for compressed versions.
  35.   (let ((compressed nil)
  36.     ;;
  37.     ;; F*** *U** **C* ***K!!!
  38.     ;; We cannot just use insert-file-contents-literally here, because
  39.     ;; then we would lose big time with ange-ftp.  *sigh*
  40.     (crypt-encoding-alist nil)
  41.     (jka-compr-compression-info-list nil)
  42.     (jam-zcat-filename-list nil)
  43.     (file-coding-system-for-read mule-no-coding-system)
  44.     (coding-system-for-read mule-no-coding-system))
  45.     (setq compressed 
  46.       (cond
  47.        ((file-exists-p fname)
  48.         (if (string-match "\\.\\(z\\|gz\\|Z\\)$" fname)
  49.         (case (intern (match-string 1 fname))
  50.           ((z gz)
  51.            (setq url-current-mime-headers (cons
  52.                            (cons
  53.                             "content-transfer-encoding"
  54.                             "gzip")
  55.                            url-current-mime-headers)))
  56.           (Z
  57.            (setq url-current-mime-headers (cons
  58.                            (cons
  59.                             "content-transfer-encoding"
  60.                             "compress")
  61.                            url-current-mime-headers))))
  62.           nil))
  63.        ((file-exists-p (concat fname ".Z"))
  64.         (setq fname (concat fname ".Z")
  65.           url-current-mime-headers (cons (cons
  66.                           "content-transfer-encoding"
  67.                           "compress")
  68.                          url-current-mime-headers)))
  69.        ((file-exists-p (concat fname ".gz"))
  70.         (setq fname (concat fname ".gz")
  71.           url-current-mime-headers (cons (cons
  72.                           "content-transfer-encoding"
  73.                           "gzip")
  74.                          url-current-mime-headers)))
  75.        ((file-exists-p (concat fname ".z"))
  76.         (setq fname (concat fname ".z")
  77.           url-current-mime-headers (cons (cons
  78.                           "content-transfer-encoding"
  79.                           "gzip")
  80.                          url-current-mime-headers)))
  81.        (t
  82.         (error "File not found %s" fname))))
  83.     (apply 'insert-file-contents fname args)
  84.     (set-buffer-modified-p nil)))
  85.  
  86. (defvar url-dired-minor-mode-map
  87.   (let ((map (make-sparse-keymap)))
  88.     (define-key map "\C-m" 'url-dired-find-file)
  89.     (if url-running-xemacs
  90.     (define-key map [button2] 'url-dired-find-file-mouse)
  91.       (define-key map [mouse-2] 'url-dired-find-file-mouse))
  92.     map)
  93.   "Keymap used when browsing directories.")
  94.  
  95. (defvar url-dired-minor-mode nil
  96.   "Whether we are in url-dired-minor-mode")
  97.  
  98. (make-variable-buffer-local 'url-dired-minor-mode)
  99.  
  100. (defun url-dired-find-file ()
  101.   "In dired, visit the file or directory named on this line, using Emacs-W3."
  102.   (interactive)
  103.   (w3-open-local (dired-get-filename)))
  104.  
  105. (defun url-dired-find-file-mouse (event)
  106.   "In dired, visit the file or directory name you click on, using Emacs-W3."
  107.   (interactive "@e")
  108.     (if (event-point event)
  109.     (progn
  110.       (goto-char (event-point event))
  111.       (url-dired-find-file))))
  112.  
  113. (defun url-dired-minor-mode (&optional arg)
  114.   "Minor mode for directory browsing with Emacs-W3."
  115.   (interactive "P")
  116.   (cond
  117.    ((null arg)
  118.     (setq url-dired-minor-mode (not url-dired-minor-mode)))
  119.    ((equal 0 arg)
  120.     (setq url-dired-minor-mode nil))
  121.    (t
  122.     (setq url-dired-minor-mode t))))
  123.  
  124. (add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map)
  125.  
  126. (defun url-format-directory (dir)
  127.   ;; Format the files in DIR into hypertext
  128.   (kill-buffer (current-buffer))
  129.   (find-file dir)
  130.   (url-dired-minor-mode t))
  131.  
  132. (defun url-host-is-local-p (host)
  133.   "Return t iff HOST references our local machine."
  134.   (let ((case-fold-search t))
  135.     (or
  136.      (null host)
  137.      (string= "" host)
  138.      (equal (downcase host) (downcase (system-name)))
  139.      (and (string-match "^localhost$" host) t)
  140.      (and (not (string-match (regexp-quote ".") host))
  141.       (equal (downcase host) (if (string-match (regexp-quote ".")
  142.                            (system-name))
  143.                      (substring (system-name) 0
  144.                         (match-beginning 0))
  145.                    (system-name)))))))
  146.  
  147. (defun url-file-build-continuation (name)
  148.   (list 'url-file-asynch-callback
  149.     name (current-buffer)
  150.     url-current-callback-func url-current-callback-data))
  151.  
  152. (defun url-file-asynch-callback (x y name buff func args &optional efs)
  153.   (if (featurep 'efs)
  154.       ;; EFS passes us an extra argument
  155.       (setq name buff
  156.         buff func
  157.         func args
  158.         args efs))
  159.   (cond
  160.    ((not name) nil)
  161.    ((not (file-exists-p name)) nil)
  162.    (t
  163.     (if (not buff)
  164.     (setq buff (generate-new-buffer " *url-asynch-file*")))
  165.     (set-buffer buff)
  166.     (insert-file-contents-literally name)
  167.     (condition-case ()
  168.     (delete-file name)
  169.       (error nil))))
  170.   (if func
  171.       (apply func args)
  172.     (url-sentinel (current-buffer) nil)))
  173.  
  174. (defun url-file (url)
  175.   ;; Find a file
  176.   (let* ((urlobj (url-generic-parse-url url))
  177.      (user (url-user urlobj))
  178.      (pass (url-password urlobj))
  179.      (site (url-host urlobj))
  180.      (file (url-unhex-string (url-filename urlobj)))
  181.      (dest (url-target urlobj))
  182.      (filename (if (or user (not (url-host-is-local-p site)))
  183.                (concat "/" (or user "anonymous") "@" site ":" file)
  184.              (if (and (memq system-type
  185.                     '(emx ms-dos windows-nt ms-windows))
  186.                   (string-match "^/[a-z][A-Z]:/" file))
  187.              (substring file 1)
  188.                file)))
  189.      (viewer (mm-mime-info
  190.           (mm-extension-to-mime (url-file-extension file))))
  191.      (pos-index (if url-directory-index-file
  192.             (expand-file-name url-directory-index-file filename))))
  193.     (url-clear-tmp-buffer)
  194.     (and user pass
  195.      (cond
  196.       ((featurep 'ange-ftp)
  197.        (ange-ftp-set-passwd site user pass))
  198.       ((or (featurep 'efs) (featurep 'efs-auto))
  199.        (efs-set-passwd site user pass))
  200.       (t
  201.        nil)))
  202.     (if (and pos-index
  203.          (file-exists-p pos-index)
  204.          (file-readable-p pos-index))
  205.     (setq filename pos-index))
  206.     (setq url-current-mime-type (mm-extension-to-mime
  207.                  (url-file-extension filename)))
  208.     (cond
  209.      ((file-directory-p filename)
  210.       (if (not (string-match "/$" filename))
  211.       (setq filename (concat filename "/")))
  212.       (if (not (string-match "/$" file))
  213.       (setq file (concat file "/")))
  214.       (url-set-filename urlobj file)
  215.       (url-format-directory filename))
  216.      (url-be-asynchronous
  217.       (cond
  218.        ((file-exists-p filename) nil)
  219.        ((file-exists-p (concat filename ".Z"))
  220.     (setq filename (concat filename ".Z")))
  221.        ((file-exists-p (concat filename ".gz"))
  222.     (setq filename (concat filename ".gz")))
  223.        ((file-exists-p (concat filename ".z"))
  224.     (setq filename (concat filename ".z")))
  225.        (t nil))
  226.       (let ((new (mm-generate-unique-filename)))
  227.     (cond
  228.      ((url-host-is-local-p site)
  229.       (if (and (file-exists-p filename)
  230.            (file-readable-p filename))
  231.           (insert-file-contents-literally filename))
  232.       (if (featurep 'efs)
  233.           (url-file-asynch-callback nil nil nil nil nil
  234.                     url-current-callback-func
  235.                     url-current-callback-data)
  236.         (url-file-asynch-callback nil nil nil nil
  237.                       url-current-callback-func
  238.                       url-current-callback-data)))
  239.      ((featurep 'ange-ftp)
  240.       (ange-ftp-copy-file-internal filename (expand-file-name new) t
  241.                        nil t
  242.                        (url-file-build-continuation new)
  243.                        t))
  244.      ((or (featurep 'efs) (featurep 'efs-auto))
  245.       (autoload 'efs-copy-file-internal "efs")
  246.       (efs-copy-file-internal filename (efs-ftp-path filename)
  247.                   new (efs-ftp-path new)
  248.                   t nil 0
  249.                   (url-file-build-continuation new)
  250.                   0 nil)))))
  251.      (t
  252.       (let ((errobj nil))
  253.     (if (or url-source        ; Need it in a buffer
  254.         (and (symbolp viewer)
  255.              (not (eq viewer 'w3-default-local-file)))
  256.         (stringp viewer))
  257.         (condition-case errobj
  258.         (url-insert-possibly-compressed-file filename t)
  259.           (error
  260.            (url-save-error errobj)
  261.            (url-retrieve (concat "www://error/nofile/" file))))))))))
  262.  
  263. (fset 'url-ftp 'url-file)
  264.  
  265. (provide 'url-file)
  266.